Programmers Heaven 2

home *** CD-ROM | disk | FTP | other *** search

/ Programmers Heaven 2 / Programmers Heaven 2.iso / files / windows / ocx / ipack.exe / NEWSV.FRM (.txt) < prev next >

Wrap

Visual Basic Form | 1996-09-22 | 21.5 KB | 688 lines

VERSION 2.00 Begin Form NewsForm BackColor = &H00C0C0C0& Caption = "Mabry News" ClientHeight = 7740 ClientLeft = 1035 ClientTop = 1770 ClientWidth = 10350 Height = 8430 Left = 975 LinkTopic = "Form1" ScaleHeight = 7740 ScaleWidth = 10350 Top = 1140 Width = 10470 Begin MabryNews News1 Blocking = 0 'False Debug = 1 'Enabled Host = "" Left = 9480 PostingHost = "" Timeout = 0 Top = 240 End Begin CommandButton cmdHSplit FontBold = -1 'True FontItalic = 0 'False FontName = "Courier New" FontSize = 0.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 90 Left = 105 TabIndex = 14 Top = 3645 Width = 9750 End Begin CommandButton cmdVSplit Height = 3090 Left = 4905 TabIndex = 13 Top = 690 Width = 90 End Begin TextBox Text1 FontBold = 0 'False FontItalic = 0 'False FontName = "Courier New" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 3015 Left = 195 MultiLine = -1 'True ScrollBars = 3 'Both TabIndex = 12 Top = 4365 Width = 9885 End Begin ListBox listArticles Height = 2955 Left = 5730 TabIndex = 11 Top = 885 Width = 4275 End Begin ListBox listGroups Height = 3150 Left = 75 TabIndex = 10 Top = 960 Width = 4515 End Begin CheckBox Flag Caption = "Flag" Height = 285 Left = 8610 TabIndex = 9 Top = 255 Visible = 0 'False Width = 690 End Begin CheckBox Check2 BackColor = &H00C0C0C0& Caption = "Trace" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 240 Left = 7290 TabIndex = 8 Top = 345 Width = 1110 End Begin CheckBox Check1 BackColor = &H00C0C0C0& Caption = "Blocking" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 240 Left = 7290 TabIndex = 7 Top = 120 Width = 1065 End Begin CommandButton cmdCancelMsg Caption = "Cancel Msg" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 6180 TabIndex = 6 Top = 120 Width = 1020 End Begin CommandButton cmdReply Caption = "Reply" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 5160 TabIndex = 5 Top = 120 Width = 1020 End Begin CommandButton cmdNewArticle Caption = "New Article" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 4140 TabIndex = 4 Top = 120 Width = 1020 End Begin CommandButton cmdGetAllGroups Caption = "All Groups" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 3120 TabIndex = 3 Top = 120 Width = 1020 End Begin CommandButton cmdGetNewGroups Caption = "New Groups" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 2100 TabIndex = 2 Top = 120 Width = 1020 End Begin CommandButton cmdDisconnect Caption = "Disconnect" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 1080 TabIndex = 1 Top = 120 Width = 1020 End Begin CommandButton cmdConnect Caption = "Connect" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 375 Left = 60 TabIndex = 0 Top = 120 Width = 1020 End Begin Line Line2 BorderColor = &H00808080& X1 = -75 X2 = 7245 Y1 = 690 Y2 = 690 End Begin Line Line1 BorderColor = &H00FFFFFF& X1 = 60 X2 = 7275 Y1 = 15 Y2 = 15 End Begin Menu FileMenu Caption = "&File" Begin Menu FileExit Caption = "E&xit" End End Begin Menu SettingsMenu Caption = "&Settings" Begin Menu SettingsUser Caption = "&User..." End Begin Menu SettingsConnection Caption = "&Connection..." End End Begin Menu ShowMenu Caption = "Sh&ow" Begin Menu ShowHeaders Caption = "&Headers" End End ' Sample program for Mabry News Control ' This sample shows both blocking and non-blocking use of ' the Mabry News control. Please note that this sample does ' not trap errors returned by the control (connection failure, ' for instance). If an error is returned you'll see the usual VB ' error message box. ' Zane Thomas/May 96 Option Explicit ' state is used in non-blocking mode to determine what to do ' when the Done and DataReady events are fired Dim State As Integer Const StateDisconnected = 0 Const StateGetGroups = 1 Const StateSelectGroup = 2 Const StateGetArticleIDs = 3 Const StateGetArticle = 4 Const StateGetHeader = 5 Const StateXOver = 6 Const StateConnecting = 7 Const StateConnected = 8 Const StateDisconnecting = 9 ' For spacing during Form_Resize Const Margin = 2 ' Used during article and group retrieval, see AddArticleIDsToList ' and Add GroupsToList for details Dim articleIndex As Integer Dim groupIndex As Integer Dim vbCrlf As String Sub AddGroupsToList (i As Integer) Dim Group As String Do While (i < News1.GroupCount) Group = News1.Groups(i) Group = Left$(Group, InStr(Group, " ") - 1) listGroups.AddItem Group i = i + 1 Loop End Sub Sub cmdCancelMsg_Click () Dim i As Integer Dim j As Integer i = InStr(g_emailaddr, "@") j = InStr(g_emailaddr, "(") - 1 News1.EMailAddress = g_emailaddr News1.PostingHost = Mid(g_emailaddr, i + 1, j - i - 1) News1.HeadersCount = 0 News1.Subject = "cmsg cancel " & News1.ArticleID News1.NewsGroups = News1.NewsGroups & ",control.cancel" News1.Headers(0) = "Control: cancel " & News1.ArticleID News1.ArticleID = Format(Now, "ddmmyyhhmmss") & "@" & News1.PostingHost News1.Date = Format(Now, "ddd, dd mmm yyyy hh:mm:ss ") & "-0700" News1.References = "" News1.BodyText = "" News1.Action = NewsPostArticle End Sub Sub cmdConnect_Click () News1.LogonName = g_logonname News1.LogonPassword = g_logonpass listGroups.Clear listArticles.Clear Text1.Text = "" If (Check1.Value = 1) Then News1.Blocking = True Else News1.Blocking = False End If EnableControls False State = StateConnecting News1.Action = NewsConnect If (News1.Blocking) Then News1_Done 0 End If End Sub Sub cmdDisconnect_Click () EnableControls False State = StateDisconnecting News1.Action = NewsDisconnect listGroups.Clear listArticles.Clear Text1.Text = "" If (News1.Blocking) Then News1_Done 0 End If End Sub Sub cmdGetAllGroups_Click () Dim i As Integer State = StateGetGroups EnableControls False listGroups.Clear groupIndex = 0 News1.Action = NewsGetAllGroups If (News1.Blocking) Then News1_Done 0 End If End Sub Sub cmdGetNewGroups_Click () State = StateGetGroups ' ' A real newsreader would keep track of the last ' time the news groups were updated and supply an ' appropriate date here ' News1.Date = Format("04/30/1996 00:00:00", "ddd, dd mmm yyyy hh:mm:ss") EnableControls False listGroups.Clear groupIndex = 0 News1.Action = NewsGetNewGroups If (News1.Blocking) Then News1_Done 0 End If End Sub Sub cmdNewArticle_Click () PostArticle False End Sub Sub cmdReply_Click () PostArticle True End Sub ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Misc Subs '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub EnableControls (fEnable As Integer) If (fEnable = False) Then cmdConnect.Enabled = fEnable cmdDisconnect.Enabled = fEnable cmdGetAllGroups.Enabled = fEnable cmdGetNewGroups.Enabled = fEnable cmdNewArticle.Enabled = fEnable cmdReply.Enabled = fEnable cmdCancelMsg.Enabled = fEnable listGroups.Enabled = fEnable listArticles.Enabled = fEnable ElseIf (State = StateConnected) Then cmdConnect.Enabled = False cmdDisconnect.Enabled = True cmdGetAllGroups.Enabled = True cmdGetNewGroups.Enabled = True cmdNewArticle.Enabled = True cmdReply.Enabled = True cmdCancelMsg.Enabled = True If (listGroups.ListCount > 0) Then listGroups.Enabled = True Else listGroups.Enabled = False End If If (listArticles.ListCount > 0) Then listArticles.Enabled = True Else listArticles.Enabled = False End If Else cmdConnect.Enabled = True cmdDisconnect.Enabled = False cmdGetAllGroups.Enabled = False cmdGetNewGroups.Enabled = False cmdNewArticle.Enabled = False cmdReply.Enabled = False cmdCancelMsg.Enabled = False listGroups.Enabled = False listArticles.Enabled = False End If End Sub Sub Form_Load () State = StateDisconnected News1.Host = "msnews.microsoft.com" News1.LogonName = "" News1.LogonPassword = "" News1.Debug = 1 vbCrlf = Chr$(13) & Chr$(10) EnableControls True Me.Show SetPopupPos UserInfo UserInfo.Show 1 End Sub Sub Form_Resize () line1.X1 = 0 Line2.X1 = 0 line1.X2 = Me.ScaleWidth Line2.X2 = Me.ScaleWidth cmdVSplit.Height = cmdHSplit.Top - Line2.Y2 - 1 cmdHSplit.Left = 0 cmdHSplit.Width = Me.ScaleWidth listGroups.Top = Line2.Y1 + Margin listGroups.Height = cmdHSplit.Top - Line2.Y1 - Margin * 2 listGroups.Left = Margin listGroups.Width = cmdVSplit.Left - Margin * 2 listArticles.Top = Line2.Y1 + Margin listArticles.Height = cmdHSplit.Top - Line2.Y1 - Margin * 2 listArticles.Left = cmdVSplit.Left + cmdVSplit.Width + Margin listArticles.Width = Me.ScaleWidth - listArticles.Left - Margin Text1.Top = cmdHSplit.Top + cmdHSplit.Height + Margin Text1.Height = Me.ScaleHeight - (cmdHSplit.Top + cmdHSplit.Height) - Margin * 2 Text1.Left = Margin Text1.Width = Me.ScaleWidth - Margin * 2 End Sub Private Sub listArticles_DblClick () ' Use this code for non-xover servers ' News1.ArticleID = News1.ArticleIDs(listArticles.ListIndex) ' cut here for non-xover servers News1.ArticleID = listArticles.ItemData(listArticles.ListIndex) ' end cut State = StateGetArticle EnableControls False News1.Action = NewsGetArticle If (News1.Blocking) Then News1_Done 0 End If End Sub Private Sub listGroups_DblClick () News1.Group = listGroups.List(listGroups.ListIndex) News1.NewsGroups = News1.Group State = StateSelectGroup EnableControls False News1.Action = NewsSelectGroup listArticles.Clear If (News1.Blocking) Then News1_Done 0 End If End Sub Sub ListHeaders () ''''''''''''''''' ' cut here for non-xover servers Dim i As Integer Dim s As String Dim n As Long For i = 0 To News1.XOverHeadersCount - 1 s = News1.XOverHeaders(i) n = Val(Left(s, InStr(s, Chr(9)) - 1)) s = Right(s, Len(s) - InStr(s, Chr(9))) s = Left(s, InStr(s, Chr(9))) listArticles.AddItem s listArticles.ItemData(i) = n Next ' end cut ''''''''''''''''' ' Use this code for non-xover servers ' Note: Getting individual headers is a whole lot slower than using ' xover. ' If (News1.Blocking) Then ' Do While articleIndex < News1.ArticleIDsCount ' News1.ArticleID = News1.ArticleIDs(articleIndex) ' News1.GetHeader ' listArticles.AddItem News1.Subject ' articleIndex = articleIndex + 1 ' DoEvents ' Loop ' Else ' If (articleIndex < News1.ArticleIDsCount) Then ' News1.ArticleID = News1.ArticleIDs(articleIndex) ' articleIndex = articleIndex + 1 ' state = StateGetHeader ' News1.GetHeader ' Else ' EnableControls True ' state = StateNone ' End If ' End If End Sub Sub News1_AsyncError (ErrorCode As Integer, ErrorMsg As String) MsgBox "AsyncError: " & ErrorMsg & "(" & Str(ErrorCode) & ")" Select Case State Case StateGetGroups, StateSelectGroup, StateGetArticleIDs, StateGetArticle, StateGetHeader, StateXOver State = StateConnected EnableControls True Case Else State = StateDisconnected EnableControls False End Select EnableControls True End Sub Sub News1_DataReady () Select Case State Case StateGetGroups AddGroupsToList groupIndex End Select End Sub Sub News1_Debug (Message As String) If (Check2.Value <> 0) Then Debug.Print Message End If End Sub Sub News1_Done (ErrorCode As Integer) Dim i As Integer Select Case State Case StateConnecting If (ErrorCode = 0) Then State = StateConnected End If EnableControls True Case StateDisconnecting State = StateDisconnected EnableControls True Case StateGetArticleIDs State = StateConnected articleIndex = 0 ListHeaders Case StateGetGroups AddGroupsToList groupIndex State = StateConnected EnableControls True Case StateSelectGroup ' ' Just finished selecting a group, get the article ids ' ' Use this code if the xover command isn't ' supported for the connected server ' state = StateGetArticleIDs ' listArticles.Clear ' News1.Date = Format("05/22/1996 12:00:00", "ddd, dd mmm yyyy hh:mm:ss") ' articleIndex = 0 ' News1.GetNewNews Flag.Value = 0 msgrange.First.Text = News1.FirstArticle msgrange.Last.Text = News1.LastArticle msgrange.Show 1 If (Flag.Value = 0) Then State = StateConnected EnableControls True Exit Sub End If '''''''''''''''''''''' ' cut this code for non-xover servers State = StateXOver News1.Action = NewsXover ' end cut '''''''''''''''''''''' If (News1.Blocking) Then ListHeaders State = StateConnected EnableControls True End If Case StateGetArticle State = StateConnected EnableControls True If (ShowHeaders.Checked) Then Text1.Text = News1.HeaderText & Chr$(13) & Chr$(10) & News1.BodyText Else Text1.Text = News1.BodyText End If Case StateGetHeader listArticles.AddItem News1.Subject ListHeaders Case StateXOver ListHeaders State = StateConnected EnableControls True Case Else State = StateConnected EnableControls True End Select End Sub Sub PostArticle (reply As Integer) Dim i As Integer Dim j As Integer Dim s As String Dim Body As String ' ' Set user info from e-mail address ' i = InStr(g_emailaddr, "@") j = InStr(g_emailaddr, "(") - 1 News1.EMailAddress = g_emailaddr News1.PostingHost = Mid(g_emailaddr, i + 1, j - i - 1) ' ' Add optional headers ' News1.HeadersCount = 0 News1.Headers(0) = "Organization: Mabry Software http://www.mabry.com" News1.Headers(1) = "X-Newsreader: Mabry News" News1.Headers(2) = "X-Test: foo" ' ' If this is a reply message ' If (reply) Then ' ' Set references line ' s = News1.References & " " & News1.ArticleID Do While (Len(s) > 512) i = InStr(s, "> <") If (i = 0) Then ' This should never happen ... but Exit Do End If s = Right(s, Len(s) - (i + 1)) Loop News1.References = s ' ' Set groups and subject ' NewMessage.NewsGroups.Text = News1.NewsGroups If (LCase$(Left(News1.Subject, 3)) <> "re:") Then NewMessage.Subject.Text = "Re: " & News1.Subject Else NewMessage.Subject.Text = News1.Subject End If ' ' Quote body text in reply ' s = News1.BodyText Body = News1.From & " wrote:" & vbCrlf Do While (s <> "") Body = Body & ">" & Left(s, InStr(s, Chr(13)) + 1) s = Right(s, Len(s) - (InStr(s, Chr(13)) + 1)) Loop NewMessage.Body.Text = Body Else ' ' New message ' NewMessage.NewsGroups.Text = News1.Group NewMessage.Subject.Text = "" News1.References = "" End If Flag.Value = 0 NewMessage.Show 1 If (Flag.Value = 0) Then Exit Sub End If News1.ArticleID = Format(Now, "ddmmyyhhmmss") & "@" & News1.PostingHost News1.Date = Format(Now, "ddd, dd mmm yyyy hh:mm:ss ") & "-0700" News1.Action = NewsPostArticle End Sub Sub SetPopupPos (foo As Form) foo.Top = Me.Top + Me.Height / 5 foo.Left = Me.Left + (Me.Width - foo.Width) / 2 End Sub Sub SettingsConnection_Click () SetPopupPos ConnectionOptionsForm ConnectionOptionsForm.Show 1 End Sub Sub SettingsUser_Click () SetPopupPos UserInfo UserInfo.Show 1 End Sub Sub ShowHeaders_Click () ShowHeaders.Checked = Not ShowHeaders.Checked If (ShowHeaders.Checked) Then Text1.Text = News1.HeaderText & Chr$(13) & Chr$(10) & News1.BodyText Else Text1.Text = News1.BodyText End If End Sub